home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue50 / Alfresco / PSProcs.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-09-04  |  7.7 KB  |  259 lines
  1. {*********************************************************}
  2. {* AAPSPrcs                                              *}
  3. {* Copyright (c) Julian M Bucknall 1998-1999             *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Algorithms Alfresco postscript routines               *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. {Warning: this unit is very much a work in progress. It will be
  14.        changing often as I build up a set of routines (maybe even
  15.        classes) to create EPS files. At present, this unit is nothing
  16.        more than a set of experimental routines. JMB}
  17.  
  18. unit PSProcs;
  19.  
  20. interface
  21.  
  22. uses
  23.   SysUtils,
  24.   Classes;
  25.  
  26. const
  27.   AAPSArrowHeight = 9;
  28.   AAPSArrowWidth = 2;
  29.  
  30. type
  31.   TaaPSPoint = packed record
  32.     X, Y : integer;
  33.   end;
  34.   TaaPSPath = array [0..99] of TaaPSPoint; {!! 99 is arbitrary}
  35.  
  36.   TaaPSIndexes = array [1..10] of integer;
  37.  
  38. procedure AAPSOutputProlog(SList : TStrings);
  39. procedure AAPSOutputEpilog(SList: TStrings);
  40.  
  41. procedure AAPSDrawLine(SList: TStrings; FromX, FromY, ToX, ToY : integer);
  42. procedure AAPSDrawSquare(SList: TStrings; aX, aY, aWidth : integer);
  43. procedure AAPSDrawRect(SList: TStrings; aX, aY, aWidth, aHeight : integer);
  44. procedure AAPSDrawRectFill(SList: TStrings; aX, aY, aWidth, aHeight : integer;
  45.                            aGray : single);
  46. procedure AAPSTracePath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  47. procedure AAPSDrawPath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  48. procedure AAPSDrawPathFill(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  49. procedure AAPSDrawText(SList: TStrings; aSt : string; aX, aY, aPoint : integer);
  50. procedure AAPSDrawArrow(SList: TStrings; aPath : TaaPSPath);
  51. procedure AAPSDrawTextInBox(SList: TStrings; aSt : string; aX, aY, aPoint : integer;
  52.                         aIndexes : TaaPSIndexes; aInxSt : string);
  53.  
  54. implementation
  55.  
  56. procedure AAPSOutputProlog(SList : TStrings);
  57. begin
  58.   with SList do begin
  59.     Add('%!PS-Adobe-3.0 EPSF-3.0');
  60.     Add('%%BoundingBox: 0 0 450 720'); {!! should calculate the size}
  61.     Add('%%Pages: 1');
  62.     Add('gsave');
  63.   end;
  64. end;
  65.  
  66. procedure AAPSOutputEpilog(SList: TStrings);
  67. begin
  68.   with SList do begin
  69.     Add('showpage');
  70.     Add('grestore');
  71.   end;
  72. end;
  73.  
  74. procedure AAPSDrawRectPrim(SList: TStrings; aX, aY, aWidth, aHeight : integer);
  75. begin
  76.   with SList do begin
  77.     Add(Format('%% draw a rect at (%d, %d) with width %d, height %d ',
  78.                [aX, aY, aWidth, aHeight]));
  79.     Add('newpath');
  80.     Add(Format('  %d %d moveto', [aX, aY]));
  81.     Add(Format('  %d 0 rlineto', [aWidth]));
  82.     Add(Format('  0 %d rlineto', [aHeight]));
  83.     Add(Format('  -%d 0 rlineto', [aWidth]));
  84.     Add('closepath');
  85.   end;
  86. end;
  87.  
  88.  
  89. procedure AAPSDrawRect(SList: TStrings; aX, aY, aWidth, aHeight : integer);
  90. begin
  91.   AAPSDrawRectPrim(SList, aX, aY, aWidth, aHeight);
  92.   with SList do begin
  93.     Add('stroke');
  94.   end;
  95. end;
  96.  
  97. procedure AAPSDrawRectFill(SList: TStrings; aX, aY, aWidth, aHeight : integer;
  98.                            aGray : single);
  99. begin
  100.   AAPSDrawRectPrim(SList, aX, aY, aWidth, aHeight);
  101.   with SList do begin
  102.     Add('gsave');
  103.     Add(Format(' %.2f setgray', [aGray]));
  104.     Add('fill');
  105.     Add('grestore');
  106.     Add('stroke');
  107.   end;
  108. end;
  109.  
  110. procedure AAPSDrawSquare(SList: TStrings; aX, aY, aWidth : integer);
  111. begin
  112.   AAPSDrawRect(SList, aX, aY, aWidth, aWidth);
  113. end;
  114.  
  115. procedure AAPSDrawLine(SList: TStrings; FromX, FromY, ToX, ToY : integer);
  116. begin
  117.   with SList do begin
  118.     Add('%% draw a line');
  119.     Add(Format('%d %d moveto', [FromX, FromY]));
  120.     Add(Format('%d %d lineto', [ToX, ToY]));
  121.     Add('stroke');
  122.   end;
  123. end;
  124.  
  125. procedure AAPSTracePath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  126. var
  127.   i : integer;
  128. begin
  129.   with SList do begin
  130.     Add('%% trace a path');
  131.     Add('newpath');
  132.     Add(Format('%d %d moveto', [aPath[0].X, aPath[0].Y]));
  133.     for i := 1 to pred(aCount) do begin
  134.       Add(Format('%d %d lineto', [aPath[i].X, aPath[i].Y]));
  135.     end;
  136.     Add('closepath');
  137.   end;
  138. end;
  139.  
  140. procedure AAPSDrawPath(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  141. begin
  142.   with SList do begin
  143.     Add('%% draw a path');
  144.     AAPSTracePath(SList, aPath, aCount);
  145.     Add('stroke');
  146.   end;
  147. end;
  148.  
  149. procedure AAPSDrawPathFill(SList: TStrings; const aPath : TaaPSPath; aCount : integer);
  150. begin
  151.   with SList do begin
  152.     Add('%% draw a path and fill');
  153.     AAPSTracePath(SList, aPath, aCount);
  154.     Add('fill');
  155.   end;
  156. end;
  157.  
  158. procedure AAPSDrawText(SList: TStrings; aSt : string; aX, aY, aPoint : integer);
  159. begin
  160.   with SList do begin
  161.     Add(Format('%% draw text at (%d, %d) with point size %d', [aX, aY, aPoint]));
  162.     Add(Format('%d %d moveto', [aX, aY]));
  163.     Add(Format('/Helvetica findfont %d scalefont setfont', [aPoint]));
  164.     Add(Format('(%s) show', [aSt]));
  165.   end;
  166. end;
  167.  
  168. procedure AAPSDrawArrow(SList: TStrings; aPath : TaaPSPath);
  169. var
  170.   Path : TaaPSPath;
  171.   Sign : integer;
  172.   Theta : double;
  173.   aX, aY, aToX, aToY : integer;
  174. begin
  175.   aX := aPath[0].X;
  176.   aY := aPath[0].Y;
  177.   aToX := aPath[1].X;
  178.   aToY := aPath[1].Y;
  179.   if (aToX = aX) then begin
  180.     {vertical}
  181.     if (aToY > aY) then
  182.       Sign := 1
  183.     else
  184.       Sign := -1;
  185.     Path[0].X := aX;
  186.     Path[0].Y := aToY - (Sign * AAPSArrowHeight);
  187.     Path[1].X := aX - AAPSArrowWidth;
  188.     Path[1].Y := Path[0].Y;
  189.     Path[2].X := aToX;
  190.     Path[2].Y := aToY;
  191.     Path[3].X := aX + AAPSArrowWidth;
  192.     Path[3].Y := Path[0].Y;
  193.   end
  194.   else begin
  195.     {other angle}
  196.     Theta := arctan((aToY - aY) / (aToX - aX));
  197.     if (aToX > aX) then
  198.       Sign := 1
  199.     else
  200.       Sign := -1;
  201.     Path[0].X := Round(aToX - Sign * (AAPSArrowHeight * cos(Theta)));
  202.     Path[0].Y := Round(aToY - Sign * (AAPSArrowHeight * sin(Theta)));
  203.     Path[1].X := Round(Path[0].X - Sign * (AAPSArrowWidth * sin(Theta)));
  204.     Path[1].Y := Round(Path[0].Y + Sign * (AAPSArrowWidth * cos(Theta)));
  205.     Path[2].X := aToX;
  206.     Path[2].Y := aToY;
  207.     Path[3].X := Round(Path[0].X + Sign * (AAPSArrowWidth * sin(Theta)));
  208.     Path[3].Y := Round(Path[0].Y - Sign * (AAPSArrowWidth * cos(Theta)));
  209.   end;
  210.   with SList do begin
  211.     Add(Format('%d %d moveto', [aX, aY]));
  212.     Add(Format('%d %d lineto', [Path[0].X, Path[0].Y]));
  213.     Add('stroke');
  214.     AAPSDrawPathFill(SList, Path, 4);
  215.   end;
  216. end;
  217.  
  218.  
  219. procedure AAPSDrawTextInBox(SList: TStrings; aSt : string; aX, aY, aPoint : integer;
  220.                         aIndexes : TaaPSIndexes; aInxSt : string);
  221. var
  222.   Width : integer;
  223.   i     : integer;
  224.   BumpCenter : integer;
  225.   X          : integer;
  226.   Arrow      : TaaPSPath;
  227. begin
  228.   {draw the boxes and text}
  229.   Width := aPoint * 3 div 2;
  230.   BumpCenter := (Width - aPoint);
  231.   X := aX;
  232.   for i := 1 to length(aSt) do begin
  233.     AAPSDrawSquare(Slist, X, aY, Width);
  234.     AAPSDrawText(SList, aSt[i], X + BumpCenter, aY + BumpCenter, aPoint);
  235.     inc(X, Width);
  236.   end;
  237.   {draw the shadow}
  238.   with SList do begin
  239.     Add('gsave');
  240.     Add('  3 setlinewidth');
  241.     Add(Format('  %d %d moveto', [aX+1, aY-1]));
  242.     Add(Format('  %d 0 rlineto', [Width * length(aSt)]));
  243.     Add(Format('  0 %d rlineto', [Width]));
  244.     Add('  stroke');
  245.     Add('grestore');
  246.   end;
  247.   for i := 1 to length(aInxSt) do begin
  248.     X := aX + (Width * (aIndexes[i] - 1));
  249.     Arrow[0].X := X + (Width div 2);
  250.     Arrow[0].Y := aY - (2 * AAPSArrowHeight);
  251.     Arrow[1].X := Arrow[0].X;
  252.     Arrow[1].Y := aY - 4;
  253.     AAPSDrawArrow(SList, Arrow);
  254.     AAPSDrawText(SList, aInxSt[i], X + BumpCenter, Arrow[0].Y - aPoint, aPoint);
  255.   end;
  256. end;
  257.  
  258. end.
  259.